Imports System.Math
Imports System
Imports System.Collections
Imports System.ComponentModel
'Imports System.Drawing
'Imports System.Threading
'Imports System.Windows.Forms
Public Class FGalaxyForm1
Public xstr(40), xend(40), ystr(40), yend(40)
Const pictdim% = 40 ' maximum picture number - array size
Const Maxpixels = 2000
Public kl(2, 30) ' GETcoulour1
Public xmax, ymax, xchrmax, ychrmax, lfn
Public xcenter, ycenter
Public colour As Long
Public xp1, yp1, xp2, yp2 ' Form1 top_left bottom_right
Public picture As Integer ' current picture number
Public picture1, picture0 As Integer ' current picture number
Public countmax
Public Amplification_old, Amplification
Public swidth, sheight
Public width1, height1
Public pos, ipnt
Public var(4) As Long
Public blank, testblank
Public dirname, filenm, flname As String
Public statex
Public buffersize As Integer
Public inputfile
Public Const trace = 0
Const posmax = 50
Const counttmax = 3500
Public timer1, timer2 As Double
Public dx, dy, xstr1, ystr1, xend1, yend1 As Double
Public x0, y0, a1 As Double
Public cancelreq As Integer
Const npmax = 4
Public nnin(npmax) As Integer
Public nnout(npmax) As Integer
Public state(npmax), np As Integer
Public Const StartSt As Integer = 1, ActiveSt As Integer = 2, StopSt As Integer = 4, CancelSt As Integer = 3, Endst As Integer = 0
Public bmp As New Bitmap(Maxpixels, Maxpixels)
Public bmp1 As New Bitmap(Maxpixels, 1)
Public bmp2 As New Bitmap(Maxpixels, 1)
Public bmp3 As New Bitmap(Maxpixels, 1)
Private Sub ButtonStart_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles ButtonStart.Click
Dim ip As Integer
GETScreen()
Debug.Print("Command Start Height" + Str(Me.Height) + "Width" + Str(Me.Width))
ip = Val(Me.TBpicture.Text)
picture1 = ip
Debug.Print("Command Start" + Str(ymax) + "Width" + Str(xmax))
If TBnproc.Text > npmax Then TBnproc.Text = Str(npmax)
If TBnproc.Text < 1 Then TBnproc.Text = Str(1)
Main()
End Sub
Private Sub ButtonEnd_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles ButtonEnd.Click
End
End Sub
Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
FGalaxyForm2.Visible = True
FGalaxyForm3.Visible = True
xstr(0) = -3 : xend(0) = 2 : ystr(0) = -2.5 : yend(0) = 2.5
xstr(0) = -2.8 : xend(0) = 1.8 : ystr(0) = -2.3 : yend(0) = 2.3
xp1 = 0 : xp2 = 1
yp1 = 0 : yp2 = 1
Amplification = 1
Amplification_old = 1
Me.TBpicture.Text = 0 ' Picture nr
Me.TBxp1.Text = xp1 ' x1 %
Me.TByp1.Text = yp1 ' y1 %
Me.TBxp2.Text = xp2 ' x2 %
Me.TByp2.Text = yp2 ' y2 %
Me.TBamplification.Text = Amplification
statex = 0
INITIALISE()
End Sub
Public Sub Main()
' DECLARE SUB VOLUME (stype%)
' FGALAXY.BAS
' Revision 1.0 Original 22 JAN 1995
' Revision 2.0 Added ' Screen update time 16 OKT 2001
' Revision 3.0 Visual Basic June 2012
' Create pictures
'
Dim ystart% ' new display 0 = yes <>0 y value
Dim Title$
Dim stpp As Integer
Dim Ampl As Double
Dim dx1, dy1 As Double ' Main
Dim lx, ly As Double
Dim kleur, power, F1, Fn As Double
Dim ystr0, yend0 As Double
Dim xx, yy, cx, cy, cxx, cyy, cp As Double
Dim countt As Integer
Dim argbcolor As Color
Dim x, y, yc As Integer
Dim npreq As Single
Dim rgb1 As Long
' Dim patt As String
''Const ESC = 27, ENTER = 13
''Const UP = 72, DOWN = 80, LEFT = 75, RIGHT = 77
Title$ = "Fractal Galaxies Demonstration"
buffersize = 2
' ***************
If picture1 >= pictdim% Then picture1 = pictdim%
GETScreen()
' Debug.Print picture1; pictdim%
' If sheight > 1000 Then Form2.PictureBox1.Height = 1000
sheight = FGalaxyForm2.PictureBox1.Height : swidth = FGalaxyForm2.PictureBox1.Width
If trace = 1 Then Debug.Print(Text)
Text = "Main Height" + Str(sheight) + " Width" + Str(swidth)
If trace = 1 Then Debug.Print(Text)
Text = "Main stpp" + Str(stpp) + " ymax" + Str(ymax) + " ystr" + Str(ystart%) + " xmax" + Str(xmax) + " picture" + Str(picture1)
Debug.Print(Text)
' Form2.Clear() ***
' ReDim bmp(xmax, ymax)
a4:
Ampl = Val(Me.TBamplification.Text)
If Ampl <> Amplification Or (xp1 <> 0 And xp2 = 1 And FGalaxyForm2.WindowState = 0) Then
' If Ampl <> Amplification Then
Text = "Main Amplification" + Str(Amplification) + " Ampl" + Str(Ampl) + " xp1" + Str(xp1) + " xp2" + Str(xp2) + " state" + Str(FGalaxyForm2.WindowState)
Debug.Print(Text)
If xp1 = 0 Then
dx1 = xend(1) - xstr(1) : dy1 = yend(1) - ystr(1)
xcenter = (xend(picture1) + xstr(picture1)) / 2
ycenter = (yend(picture1) + ystr(picture1)) / 2
If Ampl > Amplification Then picture1 = picture1 + 1
Me.TBpicture.Text = picture1 ' Picture nr
picture0 = picture1 ' save to test change
xstr(picture1) = xcenter - dx1 / 2 / Ampl
xend(picture1) = xcenter + dx1 / 2 / Ampl
ystr(picture1) = ycenter - dy1 / 2 / Ampl
yend(picture1) = ycenter + dy1 / 2 / Ampl
Else
lx = xend(picture1) - xstr(picture1) : ly = yend(picture1) - ystr(picture1)
xp2 = 1 : yp2 = 1 ' one modification
xcenter = xstr(picture1) + xp1 / xp2 * lx
ycenter = ystr(picture1) + yp1 / yp2 * ly
dx1 = xend(1) - xstr(1) : dy1 = yend(1) - ystr(1)
If Ampl > Amplification Then picture1 = picture1 + 1
xstr(picture1) = xcenter - dx1 / 2 / Ampl
xend(picture1) = xcenter + dx1 / 2 / Ampl
ystr(picture1) = ycenter - dy1 / 2 / Ampl
yend(picture1) = ycenter + dy1 / 2 / Ampl
xp1 = 0 : xp2 = 1
yp1 = 0 : yp2 = 1
Me.TBpicture.Text = picture1 ' Picture nr
picture0 = picture1 ' save to test change
Me.TBxp1.Text = xp1 ' x1 %
Me.TByp1.Text = yp1 ' y1 %
Me.TBxp2.Text = xp2 ' x2 %
Me.TByp2.Text = yp2 ' y2 %
End If
Else
SETSTANDARD() 'set standard demo parameters.
End If
statex = 0
xstr1 = xstr(picture1) : xend1 = xend(picture1) : ystr1 = ystr(picture1) : yend1 = yend(picture1)
dx = (xend1 - xstr1) / xmax : dy = (yend1 - ystr1) / ymax
x0 = -0.7 : y0 = 0.27 : a1 = 0.9 : kleur = 0
power = 10 ^ 10
Text = "Main dx" + Str(Int(dx * power) / power) + " dy" + Str(Int(dy * power) / power) + " xstr1" + Str(Int(xstr1 * power) / power) + " xend1" + Str(Int(xend1 * power) / power) + " ystr1" + Str(Int(ystr1 * power) / power) + " yend1" + Str(Int(yend1 * power) / power)
Debug.Print(Text)
Me.TBxcenter.Text = Int(xcenter * power) / power
' Form1.Text1(7).Text = Int(xend1 * power) / power
Me.TBycenter.Text = Int(ycenter * power) / power
' Form1.Text1(9).Text = Int(yend1 * power) / power
F1 = (xend(1) - xstr(1)) * (yend(1) - ystr(1))
Fn = (xend(picture1) - xstr(picture1)) * (yend(picture1) - ystr(picture1))
Amplification_old = Amplification
Amplification = F1 / Fn
Amplification = Int(Sqrt(Amplification) + 0.5)
Me.TBamplification.Text = Amplification
npreq = TBnproc.Text
Assign(npreq)
Const pp As Single = 1
TBnp.Text = Str(np)
BinaryFile_Init()
ystr0 = 0 : yend0 = ymax - 1 : stpp = 1
If filenm <> "" Then ystr0 = ymax - 1 : yend0 = 0 : stpp = -1 ' bottom up
timer1 = DateAndTime.Timer
yc = ystr0
Do
' For Y% = ystr0 To yend0 Step stpp
' For Y% = 0 To ymax - 1 Step stpp
' DoEvents()
Application.DoEvents()
For i = 1 To np
nnin(i) = yc : yc = yc + stpp
state(i) = StartSt
Next i
y = nnin(pp)
Me.TBcmax2.Text = Str(y)
For x = 0 To xmax - 1 Step 1
xx = xstr1 + x * dx
yy = ystr1 + y * dy
cx = xx : cy = yy
countt = 0
nnout(pp) = x
Do
countt = countt + 1
cxx = cx * cx * (1 - a1 * cy) - cy * cy * (1 - a1 * cx) + x0
cyy = 2 * cy * cx + y0
cx = cxx : cy = cyy
cp = cx * cx + cy * cy
Loop Until cp >= 20 Or countt > counttmax
GetArgbcolor(countt, argbcolor)
If countt > countmax Then countmax = countt
bmp.SetPixel(x, y, argbcolor)
Next x
state(pp) = StopSt
For i = 1 To np
Do
Application.DoEvents()
Loop Until state(i) = StopSt
y = nnin(i)
If i > 1 Then
For x = 0 To xmax - 1 Step 1
Select Case i
Case 2
argbcolor = bmp1.GetPixel(x, 0)
Case 3
argbcolor = bmp2.GetPixel(x, 0)
Case 4
argbcolor = bmp3.GetPixel(x, 0)
End Select
bmp.SetPixel(x, y, argbcolor)
Next x
End If
Dim alpha, red, green, blue As Single
alpha = 255
If filenm <> "" Then
For x% = 0 To xmax - 1 Step 1
testblank = 0
If x% = xmax - 1 Then testblank = 1 ' write blank
argbcolor = bmp.GetPixel(x%, y)
rgb1 = argbcolor.ToArgb
If rgb1 < 0 Then rgb1 = rgb1 + 2 ^ 32
blue = rgb1 Mod 256
rgb1 = Int(rgb1 / 256)
green = rgb1 Mod 256
rgb1 = Int(rgb1 / 256)
red = rgb1 Mod 256
BinaryFile(red, green, blue)
Next x%
End If
Next i
FGalaxyForm2.PictureBox1.Image = bmp
Me.TBcmax1.Text = countmax
Loop Until (stpp = 1 And yc >= yend0) Or (stpp = -1 And yc <= yend0)
timer2 = DateAndTime.Timer
FGalaxyForm3.TBtime.Text = Str(Int((timer2 - timer1) * 10) / 10)
Cancel(1)
TBnp.Text = Str(np)
If filenm = "" Then Exit Sub
Debug.Print("Main pos" + Str(pos))
inputfile.Close()
Exit Sub
End Sub
Sub GETScreen()
' ' GET' Screen
Dim mmax As Integer
xmax = Val(FGalaxyForm2.PictureBox1.Width)
ymax = Val(FGalaxyForm2.PictureBox1.Height)
mmax = Val(Me.TBsize.Text) 'Target
If FGalaxyForm2.WindowState = 0 Then
If xmax <> mmax Or ymax <> mmax Then
' Height 0 510 Width 0 120
' Height 200 3510 Width 200 3120
' Height 300 5010 Width 300 4620
' Height 500 8010 Width 500 7620
Debug.Print("GETscreen" + Str(mmax))
FGalaxyForm2.PictureBox1.Width = mmax : xmax = mmax
FGalaxyForm2.PictureBox1.Height = mmax : ymax = mmax
FGalaxyForm2.Width = mmax + 18
FGalaxyForm2.Height = mmax + 40
FGalaxyForm2.Visible = False
Application.DoEvents()
FGalaxyForm2.Visible = True
End If
End If
End Sub
Sub INITIALISE()
' INITIALISE
picture0 = 0 ' picture number (initial )
picture1 = picture0 ' picture number
' Initialise subroutine GetArgbcolor
kl(0, 0) = 0 : kl(1, 0) = 0 : kl(2, 0) = 0 ' white
kl(0, 1) = 1 : kl(1, 1) = 0.5 : kl(2, 1) = 0.5
kl(0, 2) = 0 : kl(1, 2) = 1 : kl(2, 2) = 1
kl(0, 3) = 0.5 : kl(1, 3) = 0 : kl(2, 3) = 0.5
kl(0, 4) = 1 : kl(1, 4) = 1 : kl(2, 4) = 0
kl(0, 5) = 0 : kl(1, 5) = 0.5 : kl(2, 5) = 0.5
kl(0, 6) = 1 : kl(1, 6) = 0 : kl(2, 6) = 1
kl(0, 7) = 0.5 : kl(1, 7) = 1 : kl(2, 7) = 0.5
kl(0, 8) = 1 : kl(1, 8) = 0 : kl(2, 8) = 0
kl(0, 9) = 0.5 : kl(1, 9) = 0.5 : kl(2, 9) = 1
kl(0, 10) = 0 : kl(1, 10) = 1 : kl(2, 10) = 0
kl(0, 11) = 1 : kl(1, 11) = 0.5 : kl(2, 11) = 0.5
kl(0, 12) = 0 : kl(1, 12) = 0 : kl(2, 12) = 1
kl(0, 13) = 0.5 : kl(1, 13) = 0.5 : kl(2, 13) = 0
kl(0, 14) = 1 : kl(1, 14) = 1 : kl(2, 14) = 1 ' black
kl(0, 15) = 0 : kl(1, 15) = 0 : kl(2, 15) = 0 ' white
kl(0, 16) = 1 : kl(1, 16) = 0.5 : kl(2, 16) = 0.5
kl(0, 17) = 0 : kl(1, 17) = 1 : kl(2, 17) = 1
kl(0, 18) = 0.5 : kl(1, 18) = 0 : kl(2, 18) = 0.5
kl(0, 19) = 1 : kl(1, 19) = 1 : kl(2, 19) = 0
kl(0, 20) = 0 : kl(1, 20) = 0.5 : kl(2, 20) = 0.5
kl(0, 21) = 1 : kl(1, 21) = 0 : kl(2, 21) = 1
kl(0, 22) = 0.5 : kl(1, 22) = 1 : kl(2, 22) = 0.5
kl(0, 23) = 1 : kl(1, 23) = 0 : kl(2, 23) = 0
kl(0, 24) = 0.5 : kl(1, 24) = 0.5 : kl(2, 24) = 1
kl(0, 25) = 0 : kl(1, 25) = 1 : kl(2, 25) = 0
kl(0, 26) = 1 : kl(1, 26) = 0.5 : kl(2, 26) = 0.5
kl(0, 27) = 0 : kl(1, 27) = 0 : kl(2, 27) = 1
kl(0, 28) = 0.5 : kl(1, 28) = 0.5 : kl(2, 28) = 0
kl(0, 29) = 1 : kl(1, 29) = 1 : kl(2, 29) = 1 ' black
GETScreen()
End Sub
Sub SETSTANDARD()
' SETSTANDARD
Dim power As Long
Dim lx, ly, lx1, ly1, l1, l2 As Double
power = 10 ^ 7
' Test that both coordinates are modified
If xp2 = 1 Then xp1 = 0 : yp1 = 0
If picture1 <> picture0 Then xp1 = 0 : yp1 = 0 : xp2 = 1 : yp2 = 1
lx = xend(picture1) - xstr(picture1) : ly = yend(picture1) - ystr(picture1)
lx1 = xp2 - xp1 : ly1 = yp2 - yp1
l2 = lx1 * ly1 : l1 = Sqrt(l2)
xend(picture1 + 1) = xstr(picture1) + lx * xp2
xstr(picture1 + 1) = xstr(picture1) + lx * xp1
yend(picture1 + 1) = ystr(picture1) + ly * yp2
ystr(picture1 + 1) = ystr(picture1) + ly * yp1
Text = "SETSTANDARD" + Str(picture1) + "xp1" + Str(Int(xp1 * power) / power) + "xp2" + Str(Int(xp2 * power) / power) + "yp1" + Str(Int(yp1 * power) / power) + "yp2" + Str(Int(yp2 * power) / power) + "lx*ly" + Str(Int(l1 * power) / power)
If trace = 1 Then Debug.Print(Text)
If (xp1 <> 0 Or picture1 = 0) And l1 > 0.01 Then picture1 = picture1 + 1
xp1 = 0 : xp2 = 1
yp1 = 0 : yp2 = 1
Me.TBpicture.Text = picture1 ' Picture nr
picture0 = picture1 ' save to test change
Me.TBxp1.Text = xp1 ' x1 %
Me.TByp1.Text = yp1 ' y1 %
Me.TBxp2.Text = xp2 ' x2 %
Me.TByp2.Text = yp2 ' y2 %
Square(xstr(picture1), xend(picture1), ystr(picture1), yend(picture1))
Text = "SETSTANDARD" + Str(picture1) + Str(Int(xstr(picture1) * power) / power) + Str(Int(xend(picture1) * power) / power) + Str(Int(ystr(picture1) * power) / power) + Str(Int(yend(picture1) * power) / power) + "lx*ly" + Str(Int(l1 * power) / power)
If trace = 1 Then Debug.Print(Text)
End Sub
Public Sub GetArgbcolor(ByVal ip As Integer, ByRef argbcolor As Color)
Dim jmax, n, ns, i As Integer
Dim expp, j, ip1 As Double
Dim deltakl As Double
Dim rgbx(2) As Integer ' GETcoulour1
Dim alpha, red, green, blue As Single
jmax = 5
n = 1
ns = 50
' Form2.DrawWidth = n
ip1 = ip - 1
expp = Exp(-ip1 / 280)
ip1 = ip1 * expp
j = ip1 / jmax
i = Int(j)
j = j - i
If i > 28 Then i = 29 : j = 1
For ikl = 0 To 2
deltakl = kl(ikl, i + 1) - kl(ikl, i)
rgbx(ikl) = kl(ikl, i) * 255 + Int(deltakl * 255 * j)
Next ikl
' Debug.Print("GetArgbcolor ip" + Str(ip) + " ip1" + Str(Int(ip1 * 100) / 100) + " i" + Str(i) + " j" + Str(Int(j * 100) / 100))
' rgbx(0) = red: rgbx(1) = green: rgbx(2) = blue
' colour = RGB(rgbx(0), rgbx(1), rgbx(2)) ' red green blue
red = rgbx(0) : green = rgbx(1) : blue = rgbx(2) : alpha = 255
argbcolor = Color.FromArgb(alpha, red, green, blue)
End Sub
Public Sub Square(ByRef xp1, ByRef xp2, ByRef yp1, ByRef yp2)
Dim X1, X2, Y1, Y2, area, lx, ly As Double
Dim dx, dy As Double
' Debug.Print "Square"; xp1; "xp2"; xp2; "yp1"; yp1; "yp2"; yp2
' adjust the coordinates to square
X1 = xp1 : X2 = xp2 : Y1 = yp1 : Y2 = yp2
dx = X2 - X1 : dy = Y2 - Y1
area = dx * dy
lx = Sqrt(area * swidth / sheight) : ly = area / lx
xcenter = (X1 + X2) / 2 : ycenter = (Y1 + Y2) / 2
xp1 = xcenter - lx / 2 : xp2 = xcenter + lx / 2
yp1 = ycenter - ly / 2 : yp2 = ycenter + ly / 2
' Debug.Print X, Y, l
Debug.Print("Square " + Str(xp1) + "xp2" + Str(xp2) + "yp1" + Str(yp1) + "yp2" + Str(yp2) + Str(swidth) + Str(sheight))
End Sub
Public Sub BinaryFile_Init()
Dim hdr(13) As Long
Dim area As Double
Dim patt As String
Dim Numberofrecords As Long
Dim width2 As Integer
Dim lheader = 26
Dim bytes = New Byte(buffersize - 1) {}
width1 = swidth
height1 = sheight
filenm = LTrim$(Me.TBfilename.Text)
dirname = LTrim$(Me.TBdirname.Text)
' C:\Users\Gebruiker\Documents\Visual Studio 2010\Projects\VB2010 FGalaxy\VB2010 FGalaxy\bin\Debug
If filenm = "" Then Exit Sub
filenm = dirname + filenm
filenm = filenm + "." + LTrim$(Str(width1)) + "." + LTrim$(Str(Amplification))
filenm = filenm + ".X" + LTrim$(Str(xcenter)) + ".Y" + LTrim$(Str(ycenter)) + ".BMP"
Dim file As System.IO.FileStream
file = System.IO.File.Create(filenm)
file.Close()
Application.DoEvents()
inputfile = IO.File.Open(filenm, IO.FileMode.Open)
Numberofrecords = 0 ' LOF(1) ***
Debug.Print(filenm + " Numberofrecords" + Str(Numberofrecords))
hdr(1) = Asc("M") * 256 + Asc("B")
width2 = width1
blank = width1 Mod 4
area = (width1 * 3 + blank) * height1 + lheader
hdr(2) = area
hdr(3) = 0
Debug.Print("BinaryFile_Init width1" + Str(width1) + Str(height1) + Str(area))
If area > 2 ^ 16 Then
hdr(3) = Int(area / 2 ^ 16)
hdr(2) = area - hdr(3) * 2 ^ 16
End If
hdr(6) = lheader
hdr(8) = 12
hdr(10) = width1
hdr(11) = height1
hdr(12) = 1
hdr(13) = 16 + 8
pos = 1
patt = ""
For i = 1 To 13
bytes(0) = hdr(i) Mod 256
bytes(1) = Int(hdr(i) / 256)
inputFile.Write(bytes, 0, buffersize)
Hex(hdr(i), patt)
If trace = 1 Then Debug.Print("BinaryFile_Init " + Str(pos) + Str(hdr(i)) + patt)
pos = pos + 2
Next i
ipnt = 0
End Sub
Public Sub BinaryFile(red, green, blue)
Dim in1 As Long
Dim in2 As Integer
Dim rgb1(3) As Long
Dim patt As String
Dim bytes = New Byte(buffersize - 1) {}
' rgbx(0) = red: rgbx(1) = green: rgbx(2) = blue
' colour = RGB(rgbx(0), rgbx(1), rgbx(2)) ' red green blue
''rgb1(0) = blue: rgb1(1) = green: rgb1(2) = red: rgb1(3) = 255
' rgb1(0) = rgbx(2) : rgb1(1) = rgbx(1) : rgb1(2) = rgbx(0)
' rgb1(3) = rgb1(0) ' Not used
var(ipnt) = blue ' rgb1(0)
var(ipnt + 1) = green ' rgb1(1)
var(ipnt + 2) = red ' rgb1(2)
bytes(0) = var(0)
bytes(1) = var(1)
inputfile.Write(bytes, 0, buffersize)
If pos < posmax And trace = 1 Then
patt = ""
Hex(in2, patt)
Debug.Print("BinaryFile pos " + Str(pos) + Str(in2) + patt)
End If
pos = pos + 2
ipnt = ipnt + 1
var(0) = var(2)
var(1) = var(3)
If ipnt = 2 Or (testblank = 1 And blank Mod 2 = 1) Then ' Blank = 1 or 3
in1 = var(1) * 256 + var(0) ' long
in2 = in1
bytes(0) = var(0) ' in2 Mod 256
bytes(1) = var(1) ' Int(in2 / 256)
inputfile.Write(bytes, 0, buffersize)
patt = ""
If pos < posmax And trace = 1 Then
Hex(in2, patt)
Debug.Print("BinaryFile pos " + Str(pos) + Str(in2) + patt)
End If
pos = pos + 2
ipnt = 0
End If
If testblank = 1 And blank >= 2 Then
in2 = 0 : in1 = 0
If pos < posmax And trace = 1 Then
patt = ""
Hex(in1, patt)
Debug.Print("BinaryFile pos " + Str(pos) + Str(in1) + patt)
End If
bytes(0) = in2 Mod 256
bytes(1) = Int(in2 / 256)
inputfile.Write(bytes, 0, buffersize)
pos = pos + 2
End If
End Sub
Public Sub Hex(ByVal in1 As Long, ByRef a$)
Dim a1(8)
Dim signx, in2 As Integer
Dim r, chr1 As String
in2 = in1
signx = 0
If in2 < 0 Then in2 = 2 ^ 31 + in1 : signx = 1
r = "" : chr1 = "" ' ** 611
For i = 0 To 8
a1(i) = in2 Mod 16
in2 = Int(in2 / 16)
If i = 7 And signx = 1 Then a1(i) = a1(i) + 8
If a1(i) < 10 Then
chr1 = Chr(Asc("0") + a1(i)) ' ***
Else
chr1 = Chr(Asc("A") + a1(i) - 10) ' ***
End If
r = chr1 + r
' Debug.Print i; in2; a1(i); chr1; r
Next i
a$ = r
' Debug.Print("Hex " + a$)
End Sub
Private Sub BackgroundWorker1_DoWork(sender As System.Object, e As System.ComponentModel.DoWorkEventArgs) Handles BackgroundWorker1.DoWork
' Get the BackgroundWorker object that raised this event.
Dim worker As BackgroundWorker = CType(sender, BackgroundWorker)
Const pp As Single = 2
Dim xx, yy, cx, cy, cxx, cyy, cp As Double
Dim x, y, countt As Integer
Dim argbcolor As Color
Do
If state(pp) = StartSt Then
state(pp) = ActiveSt
' Compute Fibonacci numbers pp=2
y = nnin(pp)
For x = 0 To xmax - 1 Step 1
xx = xstr1 + x * dx
yy = ystr1 + y * dy
cx = xx : cy = yy
countt = 0
nnout(pp) = x
Do
countt = countt + 1
cxx = cx * cx * (1 - a1 * cy) - cy * cy * (1 - a1 * cx) + x0
cyy = 2 * cy * cx + y0
cx = cxx : cy = cyy
cp = cx * cx + cy * cy
Loop Until cp >= 20 Or countt > counttmax
GetArgbcolor(countt, argbcolor)
If countt > countmax Then countmax = countt
bmp1.SetPixel(x, 0, argbcolor)
Next x
state(pp) = StopSt
Else
System.Threading.Thread.Sleep(1)
End If
Loop Until cancelreq = 1 Or state(pp) = CancelSt
state(pp) = Endst
End Sub
Private Sub BackgroundWorker2_DoWork(sender As System.Object, e As System.ComponentModel.DoWorkEventArgs) Handles BackgroundWorker2.DoWork
' Get the BackgroundWorker object that raised this event.
Dim worker As BackgroundWorker = CType(sender, BackgroundWorker)
Const pp As Single = 3
Dim xx, yy, cx, cy, cxx, cyy, cp As Double
Dim x, y, countt As Integer
Dim argbcolor As Color
Do
If state(pp) = StartSt Then
state(pp) = ActiveSt
' Compute Fibonacci numbers pp=2
y = nnin(pp)
For x = 0 To xmax - 1 Step 1
xx = xstr1 + x * dx
yy = ystr1 + Y * dy
cx = xx : cy = yy
countt = 0
nnout(pp) = x
Do
countt = countt + 1
cxx = cx * cx * (1 - a1 * cy) - cy * cy * (1 - a1 * cx) + x0
cyy = 2 * cy * cx + y0
cx = cxx : cy = cyy
cp = cx * cx + cy * cy
Loop Until cp >= 20 Or countt > counttmax
GetArgbcolor(countt, argbcolor)
If countt > countmax Then countmax = countt
bmp2.SetPixel(x, 0, argbcolor)
Next x
state(pp) = StopSt
Else
System.Threading.Thread.Sleep(1)
End If
Loop Until cancelreq = 1 Or state(pp) = CancelSt
state(pp) = Endst
End Sub
Private Sub BackgroundWorker3_DoWork(sender As System.Object, e As System.ComponentModel.DoWorkEventArgs) Handles BackgroundWorker3.DoWork
' Get the BackgroundWorker object that raised this event.
Dim worker As BackgroundWorker = CType(sender, BackgroundWorker)
Const pp As Single = 4
Dim xx, yy, cx, cy, cxx, cyy, cp As Double
Dim x, y, countt As Integer
Dim argbcolor As Color
Do
If state(pp) = StartSt Then
state(pp) = ActiveSt
' Compute Fibonacci numbers pp=2
y = nnin(pp)
For x = 0 To xmax - 1 Step 1
xx = xstr1 + x * dx
yy = ystr1 + y * dy
cx = xx : cy = yy
countt = 0
nnout(pp) = x
Do
countt = countt + 1
cxx = cx * cx * (1 - a1 * cy) - cy * cy * (1 - a1 * cx) + x0
cyy = 2 * cy * cx + y0
cx = cxx : cy = cyy
cp = cx * cx + cy * cy
Loop Until cp >= 20 Or countt > counttmax
GetArgbcolor(countt, argbcolor)
If countt > countmax Then countmax = countt
bmp3.SetPixel(x, 0, argbcolor)
Next x
state(pp) = StopSt
Else
System.Threading.Thread.Sleep(1)
End If
Loop Until cancelreq = 1 Or state(pp) = CancelSt
state(pp) = Endst
End Sub
Private Sub Assign(ByVal npreq)
' npreq = np request np = actual
If npreq > np Then
For i = 1 To npreq
Application.DoEvents()
Select Case i
Case Is = 1
If trace = 1 Then Debug.Print("Assign " + Str(i))
Case Is = 2
BackgroundWorker1.RunWorkerAsync(i)
If trace = 1 Then Debug.Print("Assign " + Str(i))
Case Is = 3
BackgroundWorker2.RunWorkerAsync(i)
If trace = 1 Then Debug.Print("Assign " + Str(i))
Case Is = 4
BackgroundWorker3.RunWorkerAsync(i)
If trace = 1 Then Debug.Print("Assign " + Str(i))
End Select
Application.DoEvents()
Next i
End If
np = npreq
End Sub
Private Sub Cancel(ByVal npreq)
If npreq < np Then
For i = 1 To np
Application.DoEvents()
Select Case i
Case Is = 1
If trace = 1 Then Debug.Print("Cancel " + Str(i))
Case Is = 2
state(i) = CancelSt
If trace = 1 Then Debug.Print("Cancel " + Str(i))
Case Is = 3
state(i) = CancelSt
If trace = 1 Then Debug.Print("Cancel " + Str(i))
Case Is = 4
state(i) = CancelSt
If trace = 1 Then Debug.Print("Cancel " + Str(i))
End Select
Next i
End If
np = npreq
End Sub
End Class